home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / xlib.lha / xlib / wss-ext.t < prev    next >
Text File  |  1990-06-06  |  2KB  |  56 lines
  1. ;;; RHH, September, 1989.
  2. ;;; Extensions/replacements for standard Xlib interfaces, should go in xwss.sc.
  3.  
  4. (herald wss-ext)
  5.  
  6.  
  7. ;;; Write-around for XrmGetResource in the standard Scheme->C X library:
  8. (DEFINE-FOREIGN XRMGETRESOURCE*
  9.                 ("XrmGetResource" (IN REP/C-POINTER)
  10.                                   (IN REP/string)
  11.                                   (IN REP/string)
  12.                                   (IN REP/EXTEND)
  13.                                   (IN REP/EXTEND))
  14.                 REP/INTEGER)
  15.  
  16.  
  17. (DEFINE
  18.   (XRMGETRESOURCE DB NAME_STR CLASS_STR)
  19.   (LET*
  20.       ((DB (CHK-XRMdatabase DB))
  21.        (NAME_STR
  22.         (IF
  23.          (STRING? name_str)
  24.          (string->asciz! name_str)
  25.          (ERROR "Argument is incorrect type: ~s" name_str)))
  26.        (CLASS_STR
  27.         (IF
  28.          (STRING? class_str)
  29.          (string->asciz! class_str)
  30.          (ERROR "Argument is incorrect type: ~s" class_str)))
  31.        (PTYPE_STR (MAKE-bytev 4))
  32.        (PVALUE (MAKE-xrmvalue))
  33.        (RETURN-VALUE (XRMGETRESOURCE* DB NAME_STR CLASS_STR PTYPE_STR
  34. (chk-xrmvalueptr PVALUE))))
  35.     (return
  36.      RETURN-VALUE
  37.      (mref-pointer PTYPE_STR 0)
  38.      pvalue)))
  39.  
  40. (define (YrmGetResource db name_str class_str)
  41.   (receive (return-code type-chara rmvalue) (XrmGetResource db name_str class_str)
  42.     (if (zero? return-code)
  43.         '()
  44.         (let ((type-string (asciz->string type-chara)))
  45.           (if (equal? type-string "String")
  46.               (asciz->string (chk-charap (xrmvalue-addr rmvalue)))
  47.               (error "Unimplemented resource type in YrmGetResource"
  48. type-string))))))
  49.  
  50. (define (YrmMergeDatabases new into)
  51.   (let ((into-p (make-bytev 4)))
  52.     (set-mref-pointer! into-p 0 (chk-xrmdatabase into))
  53.     (XrmMergeDatabases new (type/value->pointer 'xrmdatabasep into-p))
  54.     (type/value->pointer 'xrmdatabase (mref-pointer into-p 0))))
  55.  
  56.